#! /usr/bin/env tclsh

if {0} {

    Simple RSS to HTML parser/converter CGI script (index.tcl).
    Can be used also as a standalone web server (with httpd.tcl).
    Reads TVKaista RSS/channels and RSS/channels/<channel>/flv.mediarss and 
    RSS/archives/<YYYY>/<MM>/<DD>/channels/<channel>/flv.mediarss feeds
    and produces a HTML page.
    Intended to be used on PS3 WWW browser. While standard TVKaista pages are
    usable on larger screens with mouse they are not so usable with PS3
    WWW browser on TV screen.
    So, this aims to offer better browsing on PS3.
    
    Requirements:
     TCL 8.4+
     tdom TCL library
     tcllib TCL library
    
    CGI part tested with LightTPD (might work with other servers as well)
    
    Made by:
    Jukka-Pekka Partanen (jukpart@gmail.com)

    calendar.tcl and httpd.tcl are from http://wiki.tcl.tk/
    HTTP Digest Authentication is from http://wiki.tcl.tk/6087

    License: TCL (http://www.tcl.tk/software/tcltk/license.html)
}

package provide tvkaista 0.1
namespace eval tvkaista {

    lappend ::auto_path .
    
    set ::env(LANG) "fi_FI.UTF-8"
    
    package require tdom
    package require calendar
    package require http
    package require base64
    if {![info exists ::tcl_httpd] || [string is false $::tcl_httpd]} {
	package require ncgi
    }

    variable g_months
    set g_months(01) Tammikuu
    set g_months(02) Helmikuu
    set g_months(03) Maaliskuu
    set g_months(04) Huhtikuu
    set g_months(05) Toukokuu
    set g_months(06) Kesäkuu
    set g_months(07) Heinäkuu
    set g_months(08) Elokuu
    set g_months(09) Syyskuu
    set g_months(10) Lokakuu
    set g_months(11) Marraskuu
    set g_months(12) Joulukuu

    variable html_reply
    
    variable geturl_proc "geturl_auth"

    if {[regexp {digest} $geturl_proc]} {
	package require digest
    }

    variable username
    variable password
    variable tvk_url_pre
    variable img_url_pre
    variable use_thumbnails
    source settings.tcl
    if {![info exists ::tcl_httpd] || [string is false $::tcl_httpd]} {

	variable loc_url_pre $loc_url_pre_cgi

    } else {

	variable loc_url_pre $loc_url_pre_tcl
	catch {
	    set tmp [glob -directory thumb-cache *]
	    foreach f $tmp {
		file delete $f
	    }
	}
    }
}

proc tvkaista::put_html {str} {
    
    variable html_reply
#    puts $str
    append html_reply "$str\n"
}

proc tvkaista::geturl_auth {url {content_type_var ""} {len_var ""}} {
 
    variable username
    variable password

    set auth "Basic [base64::encode $username:$password]"
    set headerl [list Authorization $auth]
    set tok [http::geturl $url -headers $headerl]
    set res [http::data $tok]
    upvar #0 $tok state
    set err ""
    if {[http::ncode $tok] != 200} {
	set err [http::code $tok]
    }
    if {[string length $content_type_var] > 0} {
	upvar $content_type_var ctype
	set ctype $state(meta)
    }
    if {[string length $len_var] > 0} {
	upvar $len_var len
	set len $state(totalsize)
    }
    http::cleanup $tok
    if {[string length $err] > 0} {
	return -code error $err
    }
    return $res
}

proc tvkaista::geturl_auth_digest {url {content_type_var ""} {len_var ""}} {
    
    set hdr {}
    set try_count 0
    while {$try_count < 5} {
	set tok [http::geturl $url -headers $hdr]
	if {[http::ncode $tok] == 401} {
	    
	    set failed [catch {
		digest::Parse $tok
	    } args]
	    if {$failed} {

		http::cleanup $tok
		return -code error $args
	    }
	    set hdr [list Authorization [eval [list digest::Header] $args]]
	} else {
	    break
	}
	incr try_count
    }
    
    set err ""
    if {[http::ncode] != 200} {
	set err [http::code]
    }
    
    set res [http::data $tok]
    upvar #0 $tok state
    if {[string length $content_type_var] > 0} {
	upvar $content_type_var ctype
	set ctype $state(meta)
    }
    if {[string length $len_var] > 0} {
	upvar $len_var len
	set len $state(totalsize)
    }
    http::cleanup $tok
    if {[string length $err] > 0} {
	return -code error $err
    }
    return $res
}

proc tvkaista::put_calendar {channel path_info} {

    ::calendar::setfirstweekday 1
    set hdr [::calendar::WeekHeader 2]

    set curr_day [clock format [clock seconds] -format {%d}]
    set curr_day [string trimleft $curr_day 0]
    set curr_month [clock format [clock seconds] -format {%m}]
    set curr_year [clock format [clock seconds] -format {%Y}]
    set prev_year $curr_year
    set prev_month [expr [string trimleft $curr_month 0] - 1]
    if {$curr_month == 1} {
	set prev_month 12
	if {$curr_day < 15} {
	    set prev_year [expr $curr_year - 1]
	}
    }

    if {[regexp {archives/[0-9]+/[0-9][0-9]?/([0-9][0-9]?)} $path_info all d]} {
	set highlight_day $d
    } else {
	set highlight_day $curr_day
    }

    variable g_months
    variable loc_url_pre
    variable img_url_pre
    variable tvk_url_pre

    put_html "<table border=0>"

    put_html "<tr>"
    if {[expr $curr_day - 14] < 0} {
	if {$curr_month != 1} {
	    set prev_month [format %02d $prev_month]
	    put_html "<td align=center>[set g_months($prev_month)]</td>"
	} else {
	    put_html "<td align=center>[set g_months(12)]</td>"
	}
    }
    put_html "<td align=center>[set g_months($curr_month)]</td>"
    put_html "</tr>"
    
    put_html "<tr><td valign=top>"
    set prev_cal [::calendar::monthcalendar $prev_year [string trimleft $prev_month 0]]
    
    if {[expr $curr_day - 14] < 0} {
	
	set last_week [lindex $prev_cal end]
	foreach day $last_week {
	    if {$day > 0} {
		set last_day $day
	    }
	}
	set start_day [expr $last_day - 14 + $curr_day]
	
	put_html "<table border=0>"
	put_html " <tr>"
	foreach d $hdr {
	    put_html "<td>$d</td>"
	}
	put_html " </tr>"
	foreach week $prev_cal {
	    put_html " <tr>"
	    foreach day $week {
		if {$day == 0} {
		    put_html " <td>-</td>"
		    continue
		}
		if {$day <= $start_day} {
		    put_html " <td>-</td>"
		    continue
		}
		set archived "$loc_url_pre/archives/$prev_year/$prev_month/$day/channels/$channel/flv.mediarss"
		if {$day == $highlight_day} {
		    put_html " <td style=\"background-color:aqua\" valign=top><a href=\"$archived\">$day</a></td>"
		} else {
		    put_html " <td valign=top><a href=\"$archived\">$day</a></td>"
		}
	    }
	    put_html " </tr>"
	}
	put_html "</table>"
    }

    put_html "</td><td valign=top>"

    set curr_cal [::calendar::monthcalendar $curr_year [string trimleft $curr_month 0]]
    put_html "<table border=0>"
    put_html " <tr>"
    foreach d $hdr {
	put_html "<td>$d</td>"
    }
    put_html " </tr>"
    set start_day [expr $curr_day - 14]
    foreach week $curr_cal {
	put_html " <tr>"
	foreach day $week {
	    if {$day == 0} {
		put_html " <td>-</td>"
		continue
	    }
	    if {$day <= $start_day} {
		put_html " <td>-</td>"
		continue
	    }
	    if {$day != $curr_day} {
	    	set archived "$loc_url_pre/archives/$curr_year/$curr_month/$day/channels/$channel/flv.mediarss"
	    } else {
		set archived "$loc_url_pre/channels/$channel/flv.mediarss"
	    }
	    if {$day == $highlight_day} {
		put_html " <td style=\"background-color:aqua\" valign=top>"
	    } else {
		put_html " <td valign=top>"
	    }
	    put_html "<a href=\"$archived\">$day</a></td>"
	    if {$day == $curr_day} {
		break
	    }
	}
	put_html " </tr>"
	if {$day == $curr_day} {
	    break
	}
    }
    put_html "</table>"

    put_html "</td></tr>"
    put_html "</table>"

    put_html "<hr>"
}

proc tvkaista::lreverse list {
    set res {}
    set i [llength $list]
    while {$i > 0} {lappend res [lindex $list [incr i -1]]}
    set res
}

proc tvkaista::put_programs {rss {no_ch false}} {
    
    variable tvk_url_pre
    variable loc_url_pre
    variable geturl_proc
    variable use_thumbnails

    put_html "<a href=\"$loc_url_pre/channels/\">\&#60; Kanavat</a><br><br>"

    $rss documentElement root

    set title [$root selectNodes /rss/channel/title]
    set title [$title text]

    if {[string is false $no_ch]} {

	regexp {(.+) - TVkaista} $title all ch
	set ch [string tolower $ch]
	set ch [string map {" " ""} $ch]
	if {[regsub {archived .+ Channel} $title "arkisto" title_tmp] == 0} {
	    regsub -- {- TVkaista Channel} $title \
		{t\&auml;n\&auml;\&auml;n} title_tmp
	}
	put_html " <font size=+2>"
	put_html "<b><a style=\"text-decoration:none\" href = $tvk_url_pre/recordings/channel/$ch>$title_tmp</a></b></font><br><br>"
    }
    
    set items [$root selectNodes /rss/channel/item]
    set items [lreverse $items]
    foreach item $items {

	set title [$item selectNodes title]
	set title [$title text]
 	set desc [$item selectNodes description]
	if {[string length $desc] > 0} {
	    set desc [$desc text]
	}
	set pubdate [$item selectNodes pubDate]
	set pubdate [$pubdate text]
	set date_sec 0
	if {[regexp {[0-9][0-9] [[:alpha:]]+ [0-9]+ [0-9][0-9]:[0-9][0-9]:[0-9][0-9]} $pubdate date]} {
	    if {[string length $date] > 0} {
		catch {
		    set date_sec [clock scan $date -gmt 1]
		}
	    }
	    if {$date_sec > 0} {
#		set date_str [clock format $date_sec -format {%A %H:%M}]
		set date_str [clock format $date_sec -format {%A %x %H.%M}]
	    }
	}
	set link [$item selectNodes link]
	set link [$link text]

	set media_group [$item selectNodes "media:group"]

	if {[string length $media_group] > 0} {
	    
	    set thumb [$media_group selectNodes "media:thumbnail"]
	    set thumb_url [$thumb getAttribute url "nothumb.jpg"]
	    set media_url [$media_group selectNodes "media:content"]
	} else {
	    set thumb [$item selectNodes "media:thumbnail"]
	    set thumb_url [$thumb getAttribute url "nothumb.jpg"]
	    set media_url [$item selectNodes "media:content"]
	}
	
	set flash_url ""
	set mpeg2_url ""
	foreach url $media_url {
	    
	    set tmp [$url getAttribute url ""]
	    if {[regexp {2000000$} $tmp]} {
		set flash_url $tmp
	    }
	    if {[regexp {8000000$} $tmp]} {
		set mpeg2_url $tmp
	    }
	}
	
	regsub {/download/} $flash_url "/play/" flash_url
	regsub {/recordings/download/} $mpeg2_url "/ps3playback/" mpeg2_url
	put_html "<font size=+2>"
	if {[string length $flash_url] > 0} {
	    put_html "<a href=\"$flash_url\">"
	}
	put_html "$title"
	if {[string length $flash_url] > 0} {
	    put_html "</a>"
	}
	put_html "</font>"
	if {[string length $mpeg2_url] > 0} {
	    put_html " (<a href=\"$mpeg2_url\">mpeg2</a>)<br>"
	}
	put_html "$date_str<br>"
	put_html "<p><table><tr>"

	if {[string is true $use_thumbnails]} {

	    if {[catch {$geturl_proc $thumb_url ctype clen} img]} {
		
		set thumb_url "$tvk_url_pre/feed/images/nothumb.jpg"
		
	    } else {
		
		if {[file isdirectory "thumb-cache"] == 0} {
		    file mkdir "thumb-cache"
		}
		set tmp [uri::split $thumb_url]
		array set path_arr $tmp
		set fname [file split $path_arr(path)]
		set fname [lindex $fname end]
		if {[file exists "thumb-cache/$fname"] == 0} {
		    
		    set f [open "thumb-cache/$fname" w+]
		    fconfigure $f -translation binary
		    puts -nonewline $f $img
		    close $f
		}
	    }

	    set thumb_url_cache ""
	    regsub "$tvk_url_pre/feed/" \
		$thumb_url "$loc_url_pre/" thumb_url_cache
	    put_html "<td valign=top><img src=\"$thumb_url_cache\"></td>"
	}

	put_html "<td valign=top>$desc</td></tr></table></p>"
	put_html "<br>"
    }

    put_html "</font>"
    put_html "<a href=\"$loc_url_pre/channels/\">&#60; Kanavat</a>"
}

proc tvkaista::put_channels {rss} {

    variable tvk_url_pre
    variable img_url_pre
    variable loc_url_pre
    variable put_alphabetical_index
    variable search_words

    put_html " <font size=+2>"
    put_html "<b><a style=\"text-decoration:none\" href = $tvk_url_pre/recordings>TVKaista - Kanavat</a></b></font><br><br>"

    $rss documentElement root
    set items [$root selectNodes /rss/channel/item]
    foreach item $items {

	set title [$item selectNodes title]
#	set desc [$item selectNodes description]
	set link [$item selectNodes link]
	set url [$link text]
	set ch ""
	regexp {channels/([0-9]+)} $url all ch
	
	set new_url "$loc_url_pre/channels/$ch/flv.mediarss"
	# put_html "<p><a href=\"$new_url\">[$title text]</a>"
	set ch_logo_url "$img_url_pre/images/${ch}.png"
	put_html "<p><a href=\"$new_url\"><img src=\"$ch_logo_url\"></a>"
    }
    put_html " <font size=+2>"
    put_html " <br><br>"

    put_html " <b><a href=$loc_url_pre/playlist/flv.mediarss>Katselulista</a></b><br><br>"
    put_html " <b><a href=$loc_url_pre/seasonpasses/>Sarjat</a></b><br><br>"
    put_html "<b>Hakujen tulokset:</b><br></font>"
    foreach {word lnk} $search_words {

	put_html " <a href=$loc_url_pre/$lnk>$word</a><br>"
    }
    if {[string is true $put_alphabetical_index]} {

	put_html " <b><a style=\"text-decoration:none\" href=$tvk_url_pre/programlist>TVkaista - Ohjelmat A-Ö</a></b><br>"
	set i 0
	put_html "<table border=0><tr>"
	foreach {tail ltr} {/misc # /a A /b B /c C /d D /e E /f F /g G /h H /i I /j J /k K /l L /m M /n N /o O /p P /q Q /r R /s S /t T /u U /w W /x X /y Y /z Z ?choice=%E5 Å ?choice=%E4 Ä ?choice=%F6 Ö} {
	    
	    put_html "<td valign=center align=center>"
	    put_html "<a href=$tvk_url_pre/programlist${tail}/>$ltr</a></td>"
	    incr i
	    if {[expr $i % 5] == 0} {
		put_html "</tr><tr>"
	    }	
	}
	put_html " </tr></table>"
    }
    put_html "</font>"
}

proc tvkaista::put_seasonpasses {rss} {

    variable loc_url_pre

    put_html "<a href=\"$loc_url_pre/channels/\">\&#60; Kanavat</a><br><br>"
    put_html " <font size=+2>"

    $rss documentElement root
    set items [$root selectNodes /rss/channel/item]
    foreach item $items {

        set title [$item selectNodes title]
	set title [$title text]
        set link [$item selectNodes link]
        set url [$link text]
	regexp {seasonpasses/([0-9]+)} $url all id

        set new_url "$loc_url_pre/seasonpasses/$id/flv.mediarss"
        put_html "<p><a href=\"$new_url\">$title</a>"
    }
    put_html " <br><br></font>"
    put_html "<a href=\"$loc_url_pre/channels/\">\&#60; Kanavat</a><br><br>"
}

proc tvkaista::rssparse {} {

    variable html_reply
    variable tvk_url_pre
    variable geturl_proc
    set html_reply ""

    set path_info [array get ::env PATH_INFO]
    if {[llength $path_info] > 0} {
	set path_info [lindex $path_info 1]
	regsub {^/} $path_info "" path_info
    }
    
    set ch_feed true
    set film_feed false
    set seasonpasses false
    if {[regexp {channels/$} $path_info]} {
	set ch_feed true
    } elseif {[regexp {channels/([0-9]+)/?} $path_info all channel]} {
	set ch_feed false
    } elseif {[regexp {search/.+$} $path_info all]} {
	set ch_feed false
	set film_feed true
    } elseif {[regexp {playlist/.+$} $path_info all]} {
	set ch_feed false
	set film_feed true
    } elseif {[regexp {seasonpasses/$} $path_info all]} {
	set ch_feed false
	set film_feed false
	set seasonpasses true
    } elseif {[regexp {seasonpasses/([0-9]+)/.+$} $path_info all]} {
	set ch_feed false
        set film_feed true
    } else {
	
	if {![info exists ::tcl_httpd] || [string is false $::tcl_httpd]} {
	    ::ncgi::header
	}
	put_html "<html>"
	put_html " <head>"
	put_html " </head>"
	put_html " <body>"
	put_html "  <h1>Invalid path</h1>"
	put_html " </body>"
	put_html "</html>"
	if {![info exists ::tcl_httpd] || [string is false $::tcl_httpd]} {	    
	    puts $html_reply
	    exit 0
	}
	return
    }

    set rss_url "$tvk_url_pre/feed/$path_info"
    set result [catch {$geturl_proc $rss_url} rssdata]
    if {$result != 0} {
	put_html "<html>"
	put_html " <head>"
	put_html " </head>"
	put_html " <body>"
	put_html $rssdata
	put_html " </body>"
	put_html "</html>"
	puts $html_reply
	exit 0
    }
    
    if {![info exists ::tcl_httpd] || [string is false $::tcl_httpd]} {
	::ncgi::header
    }
    put_html "<html>"
    put_html " <head>"
    put_html "  <meta http-equiv=\"Content-Type\" content=\"text/html; charset=ISO-8859-1\">"
    put_html "  <meta http-equiv=\"Pragma\" content=\"no-cache\">"
    put_html " </head>"
    put_html " <body>"
    
    set err [catch {dom parse $rssdata rss} res]
    
    if {$err} {
	put_html "<h1>RSS feed DOM failure: $res</h1>"
	put_html " </body>"
	put_html "</html>"
	if {![info exists ::tcl_httpd] || [string is false $::tcl_httpd]} {
	    puts $html_reply
	    exit 0
	}
	return
    }
    
    if {[string is true $ch_feed]} {
	put_channels $rss
    } elseif {[string is true $film_feed]} {
	put_programs $rss true
    } elseif {[string is true $seasonpasses]} {
	put_seasonpasses $rss
    } else {
	put_calendar $channel $path_info
	put_programs $rss
    }
    
    put_html "<br><br>"
    set date [clock format [clock seconds] -format {%c}]
    put_html "<p>$date"
    put_html " </body>"
    put_html "</html>"
}

proc tvkaista::thumbnail {img_var} {
    
    upvar $img_var img
    set path_info [array get ::env PATH_INFO]
    set fname "images/nothumb.jpg"
    if {[llength $path_info] > 0} {
	set path_info [lindex $path_info 1]
	regsub {^(/?)thumbnails/} $path_info "thumb-cache/" fname
    }
    if {[catch {open $fname} f]} {
	set img {}
	return "HTTP/1.1 404 Not found\n\n"
    }
    set fsize [file size $fname]
    fconfigure $f -translation binary
    set img [read $f]
    close $f
    
    return "HTTP/1.1 200 OK\nCache-Control: no-cache\nContent-Type: image/jpeg\nContent-Length: $fsize\nConnection: close\n\n"
}


proc tvkaista::cgi {} {

    fconfigure stdout -translation binary
    
    if {[regexp {^(/?)thumbnails/(.+)$} $::env(PATH_INFO) all tmp fname]} {
	
	if {[catch {open "thumb-cache/$fname"} f]} {
	    if {[catch {open "images/nothumb.jpg"} f]} {
		::ncgi::header 
		puts -nonewline stdout "404 - Not Found"
		exit 0
	    }
	}
	::ncgi::header "image/jpeg"
	fconfigure $f -translation binary
	set img [read $f]
	close $f
	puts -nonewline stdout $img
	exit 0
    }
    
    variable html_reply
    rssparse
    puts $html_reply
}


if {![info exists ::tcl_httpd] || [string is false $::tcl_httpd]} {
    tvkaista::cgi
}
